MacWorld 1998 March/Macworld (1998-03) (Disk 1).dmg/Shareware World/Utilities/Text Processing/Alpha/Tcl/Modes/fortranMode.tcl

Text File | 1997-10-08 | 20.2 KB | 665 lines | [TEXT/ALFA]

#=============================================================================
# Fortran mode definition and support procs
#
# Features:
# 1.  Keyword colorization (slightly customizable)
# 2.  Fortran-sensitive shift right/left preserve columns 1-6
# 3.  Auto-indentation
# 4.  Line-breaking with Ctl-Opt-J (a la emacs)
# 5.  Subroutine indexing
# 6.  Cmd-double-click subroutine and include-file lookup
# 7.  Customizable comment and continuation characters
#
#------------------------------------------------------------------------------
# Author: Tom Pollard <[e-mail]>
#
# To Do:  work around grep failure for Unix-format tag files
#
#  8/97 - Updated for new system code.
#  4/97 - Coloring bug fixed.
#  1/96 - Fort::MarkFile no longer marks F90 "end subroutine ..." statements
#         more F90 keywords (will they never cease?)
#  1/96 - user-selectable comment and continuation characters
#         complete F90 keyword set (Thomas Bewley <[e-mail]>)
#         F90 functions and comparison operators optionally colorized ( " " )
#         more complete set of C preprocessor commands colorized
#         fixed case-sensitivity problem in line-indent routines
#  1/96 - minor Fort::DblClick bug fix
# 12/95 - more complete keyword set for F90 and HPF (from Tom Scavo)
# 12/95 - cpp keyword colorization (George Nurser <[e-mail]>)
#         cmd-dbl-click supports cpp #include now
# 11/95 - added FortBreakLine
#         fixed case-sensitivity bug
# 10/95 - fixed Cmd-Dbl-Click handler to deal w/ new(?) tag file format and
#            improve performance (fortFindSub)
#  9/95 - fixed getFortPrev bug with numbered lines
#       - shiftLeft/Right revert to normal behavior on ill-formatted lines
#  8/95 - auto-indentation is finally speedy and robust
#  5/95 - added Cmd-Dbl-Click handler
#       - added auto-indentation
# 12/94 - fixed funcExpr, Fort::MarkFile search expressions
#       - changed comment character from 'C' to 'c' (should be case-insensitive!)
#       - added 'include' keyword
#       - added FortShiftRight and FortShiftLeft procs
#------------------------------------------------------------------------------


#================================================================================
alpha::mode Fort 1.0 dummyFort \
  {*.f *.inc *.INC *.fcm *.for *.FOR *.f9 *.f90 *.hpf } {} {
    set unixMode(fortran) {Fort}
}

proc dummyFort {} {}

newPref f sortedIsDefault    {0} Fort
newPref f wordWrap        {0} Fort
newPref v funcExpr    {^[^cC*!][ \t]*(subroutine|[ \ta-z*0-9]*function|entry).*$} Fort
newPref f autoMark        {0} Fort
newPref f electricTab    {1} Fort

# newPref v prefixString {c} Fort
newPref    v continueChar    {$} Fort
newPref    v commentChar    {c} Fort shadowFort
newPref    f colorFuncs    {0} Fort shadowFort
newPref    f colorOpers    {0} Fort shadowFort

newPref f indentComment    {0} Fort
newPref v markTag        {{}} Fort

#=============================================================================
# Colorize Fortran keywords
#
proc fortColorKeywords {{color blue} {comment red} {specialChars black}} {
    global FortmodeVars

    set FortKeywords {
        allocatable allocate assign backspace block call character close common
        complex contains continue cycle data deallocate dimension do double else
        elseif end enddo endfile endif entry equivalence exit external extrinsic
        forall format function goto if implicit include inquire integer intent
        interface intrinsic logical module namelist nullify open optional
        parameter pause pointer precision print private program public pure read
        real recursive return rewind save sequence stop subroutine target then
        use where while write assignment case default elsewhere endfile go none
        operator procedure select to type
    }

    if {$specialChars != "black"} {
        regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords  -i {=}  -i {*}  -i {/}  -i {+}  -i {-}  -i {,}  -i {(} -i {)} -I $specialChars
    } else {
        regModeKeywords -e $FortmodeVars(commentChar) -c $comment -k $color Fort $FortKeywords
    }
    unset FortKeywords
}

#=============================================================================
# Colorize selected C preprocessor keywords
#
proc fortColorCPP {{color green}} {
    set CPPKeywords  {
        #if #endif #include #else #define #undef #ifdef #ifndef
    }
    regModeKeywords -a  -k $color Fort $CPPKeywords
    unset CPPKeywords
}


#=========================================================================
# Colorize Fortran operators
#
proc fortColorOpers {{color green}} {
    set FortOperators {
        eq ne lt le gt ge not and or eqv neqv true false
    }
    regModeKeywords -a -k $color Fort $FortOperators
    unset FortOperators
}

#=========================================================================
# Colorize Fortran function keywords
#
proc fortColorFuncs {{color green}} {
    # Fortran bit functions
    #
    set BitKeywords {
        bit_size btest iand ibclr ibits ibset ieor ior ishft ishftc mvbits not
    }
    regModeKeywords -a -k $color Fort $BitKeywords
    unset BitKeywords

    # Fortran intrinsic functions
    #
    set IntrinsicKeywords {
        abs acos aimag asin atan atan2 conjg cos cosh dble dim dprod exp ichar
        len lge lgt lle llt log log10 max min mod sign sin sinh sqrt tan tanh
        iabs dabs cabs dacos dint dnint dasin datan datan2 dcos ccos dcosh idim
        ddim dexp cexp ifix idint alog ddlog clog alog10 dlog10 max0 amax0 max1
        amax1 dmax1 min0 amin0 min1 amin1 dmin1 amod dmod idnint float sngl
        isign dsign dsin csin dsinh dsqrt csqrt dtan dtanh aint anint char cmplx
        index int nint achar adjustl adjustr all allocated any associated
        bit_size btest ceiling count cshift date_and_time digits dot_product
        eoshift epsilon exponent floor fraction huge iachar iand ibclr ibits
        ibset ieor ior ishft ishftc kind lbound len_trim logical matmul
        maxexponent maxloc maxval merge minexponent minloc minval modulo mvbits
        nearest not pack precision present product radix random_number
        random_seed range repeat reshape rrspacing scale scan selected_int_kind
        selected_real_kind set_exponent shape size spacing spread sum
        system_clock tiny transfer transpose trim ubound unpack verify
    }
    regModeKeywords -a -k $color Fort $IntrinsicKeywords
    unset IntrinsicKeywords
}

fortColorKeywords blue red magenta
fortColorCPP green
if {$FortmodeVars(colorFuncs)} {
    fortColorFuncs green
}
if {$FortmodeVars(colorOpers)} {
    fortColorOpers green
}
#=============================================================================
# Special Fortran keybindings
#
bind '\[' <c>  FortShiftLeft Fort
bind '\[' <co> FortShiftLeftSpace Fort
bind '\]' <c>  FortShiftRight Fort
bind '\]' <co> FortShiftRightSpace Fort

bind 'j'  <zo> FortBreakLine Fort

#=============================================================================
# Update colorization when Fortran mode variables are changed
#
proc shadowFort {name2} {
    global HOME FortmodeVars
    switch $name2 {
        "colorFuncs"    {
            if {$FortmodeVars(colorFuncs)} {
                fortColorFuncs green
            } else {
                fortColorFuncs black
            }
         }
        "colorOpers"    {
            if {$FortmodeVars(colorOpers)} {
                fortColorOpers green
            } else {
                fortColorOpers black
            }
         }
        "commentChar" {
            fortColorKeywords blue red magenta
        }
        default {
            return
        }
    }
}

#=============================================================================
#
proc Fort::MarkFile {} {
    global FortmodeVars
    set tag [quote::Regfind $FortmodeVars(markTag)]

    set pat0 {^.*(subroutine|.*function|entry|program).*$}
    set pat1 {^[^cC*!]([ \ta-z*0-9]*)(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
    set end [maxPos]
    set pos 0
    while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat1 $pos} mtch]} {
        regexp -nocase $pat1 [eval getText $mtch] allofit valtyp subtyp name
        set start [lineStart [lindex $mtch 0]]
        set next [nextLineStart $start]
        set pos $next
        if {! [regexp -nocase "end" $valtyp mtch]} {
            set inds([lineStart $start]) $name
        }

    }

    set pat2 "^(c+${tag})\[ \t\]*(\[^\n\r\]*\[^ \t\])\[^ \t\]*\$"
    set pos 0
    while {![catch {search -s -f 1 -r 1 -m 0 -i 1 $pat2 $pos} mtch]} {
        regexp -nocase $pat2 [eval getText $mtch] allofit cc comment
        regsub -all {[\/\(\)]} $comment {} comment
        set start [lindex $mtch 0]
        set end [nextLineStart $start]
        set pos $end
        set inds([lineStart $start]) $comment
    }

    if {[info exists inds]} {
        foreach f [lsort -integer [array names inds]] {
            set next [nextLineStart $f ]
            setNamedMark $inds($f) $f $f $f
        }
    }
}

#================================================================================
# Block shift left and right for Fortran mode (preserves cols 1-6)
#================================================================================

proc FortShiftLeft {} {
    global shiftChar
    doFortShiftLeft "\t"

}
proc FortShiftLeftSpace {} {
    global shiftChar
    doFortShiftLeft " "
}

proc doFortShiftLeft {shiftChar} {
    set start [lineStart [getPos]]
    set end [nextLineStart [expr [selEnd] - 1]]
    if {$start >= $end} {set end [nextLineStart $start]}

    set text [split [getText $start [expr $end - 1]] "\r"]

    set textout ""

    set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
    foreach line $text {
        if {[regexp $pat $line mtch pref body]} {
            if {[string index $body 0] == $shiftChar} {
                lappend textout $pref[string range $body 1 end]
            } else {
                lappend textout $line
            }

        } elseif {[string index $line 0] == $shiftChar} {
            lappend textout [string range $line 1 end]

        } else {
            lappend textout $line
        }
    }

    set text [join $textout "\r"]
    replaceText $start [expr $end - 1] $text
    select $start [expr 1 + $start + [string length $text]]
}

proc FortShiftRight {} {
    global shiftChar
    doFortShiftRight "\t"

}
proc FortShiftRightSpace {} {
    global shiftChar
    doFortShiftRight " "
}

proc doFortShiftRight {shiftChar} {
    set start [lineStart [getPos]]
    set end [nextLineStart [expr [selEnd] - 1]]
    if {$start >= $end} {set end [nextLineStart $start]}

    set text [split [getText $start [expr $end - 1]] "\r"]

    set textout ""

    set pat {^([cC]|[ 0-9][ 0-9][ 0-9][ 0-9][ 0-9].| *[0-9]*\t)(.*)$}
    foreach line $text {
        if {[regexp $pat $line mtch pref body]} {
            lappend textout $pref$shiftChar$body
        } else {
            lappend textout $shiftChar$line
        }
    }

    set text [join $textout "\r"]
    replaceText $start [expr $end - 1] $text
    select $start [expr 1 + $start + [string length $text]]
}

proc FortBreakLine {} {
    global FortmodeVars
    set pos [getPos]
    set line [getText [lineStart $pos] [expr [nextLineStart $pos]-1]]
    if {[regexp {^[cC*!]} $line char]} {
        insertText "\n$char "
    } else {
        set char $FortmodeVars(continueChar)
        insertText "\n     $char"
    }
    FortindentLine
}

#=============================================================================
# Cmd-double-clicking opens include files, jumps to subroutine definitions,
# and follows tags.
#
proc Fort::DblClick {from to} {
    global tagFile
    set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
    set incPat {^[^cC*!][ \t]*include[ \t]*['"]([^'"]+)['"]}

    # First check whether an 'include' was clicked
    set line [getText [lineStart $from] [expr [nextLineStart $to] - 1]]
    if {[regexp -nocase $incPat $line allofit fname]} {
        set path [absolutePath $fname]
        if {[catch {openFileQuietly $path}]} {
            message "include file \'$fname\' not found in source folder"
        }
        return
    }

    select $from $to
    set text [getSelect]

    # First check current file for subroutine definition,...
    if {![catch {fortFindSub $text} mtch]} {
        regexp -nocase $pat1 [eval getText $mtch] allofit subtyp name
        pushPosition
        display [lindex $mtch 0]
#         eval select $mtch
        message "press <Ctl .> to return to original cursor position"

    # ...then check tags file.
    } else {
        message "Searching tags file..."
        set lines [grep "^$text'" $tagFile]
        if {[regexp {'(.*)'} $lines dummy fname]} {
            pushPosition
            if {[string match "*$fname*" [winNames -f]]} {
                bringToFront $fname
            } else {
                edit $fname
            }
            set inds [fortFindSub $text]
#             set inds [search -s -f 1 -r 1 -i 1 "$pat1$text" 0]
            display [lindex $inds 0]
#             eval select $inds
            message "press <Ctl .> to return to original cursor position"
        }
    }
}

# Speedy search for a Fortran subroutine.  Performance is dramatically
# improved by scanning for the name alone first, rather than running
# complicated regexp search on the entire file.
#
proc fortFindSub {name} {
    set pat1 {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry)[ \t]+}
    set pos 0
    while {![catch {search -s -f 1 -r 0 -m 0 -i 1 $name $pos} mtch]} {
        set beg [lineStart [lindex $mtch 0]]
        set end [expr [nextLineStart [lindex $mtch 1]] -1]
        set line [getText $beg $end]
        if {[regexp  -nocase $pat1$name $line allofit subtyp name]} {
            return $mtch
        } else {
            set pos [lindex $mtch 1]
        }
    }
    error "Subroutine \"$name\" not found"
}

#=============================================================================
# Fortan auto-indentation
#
# Logic:
#    0.    Identify previous line
#            a) ignore comments and continuation lines
#            b) if current line is a CONTINUE that matches a DO, use the
#                first corresponding DO as the previous line
#
#    1.    Find leading whitespace for previous line
#
#    2.    Increase whitespace if previous line starts a block, i.e.,
#            a) DO loop
#            b) IF ... THEN
#            c) ELSE
#
#    3.    Decrease whitespace if current line ends a block, i.e.,
#            a) ELSE || ENDIF || END IF || ENDDO || END DO
#            b) <linenum> CONTINUE matching a preceding DO
#
#        or if previous line ends a DO loop on an executable statement, i.e.,
#            c) <linenum> (not CONTINUE) matching a preceding DO
#
####################################################################################
# Fortan auto-indentation
#
proc FortindentLine {} {
    set bol [lineStart [getPos]]
    set eol [expr [nextLineStart $bol] - 1]
    Fortindent $bol $eol
}

proc FortindentRegion {} {
    Fortindent [getPos] [selEnd]
}

####################################################################################
# Fortan auto-indentation of a specified region
#
proc Fortindent {pos0 pos1} {
    global fortDooz fortPrevLine fortTop msg
    global FortmodeVars

    set tag [quote::Regfind $FortmodeVars(markTag)]
    set doComment $FortmodeVars(indentComment)

    # Define regexps
    set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}
    set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
    set mtPat {^[ \t]*$}
    set tab "    "

    set contPat {^     ([^ \t\n\r])[^\r\n]*$}
    set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
    set comPat "^(\[cC*!\]+(${tag})?)(\[ \t\]*)(.*)\$"
    set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
    set tailPat {[^\r\n]*$}

    set bobPat {^(if[^\n\r]*then|else|do)}
    set eobPat {^(end[ \t]*if|end[ \t]*do|else)}
    set enddoPat {^(end[ \t]*do|continue)}

#     set fortTop [fortSubTop $pos0]
    set fortTop -1

    catch {unset fortDooz}
    set fortPrevLine ""

    # Loop over region line by line
    set from [lindex [posToRowCol $pos0] 0]
    set to [lindex [posToRowCol $pos1] 0]

    while {$from <= $to} {
        set msg "Indenting line $from"
        message $msg
        set bol [lineStart [rowColToPos $from 0]]
        set eol [expr [nextLineStart $bol] - 1]
        set thisLine [getText $bol $eol]
        goto $bol

        # Check whether we're entering a new routine
        #
        if {[regexp $subPat $thisLine allofit subType subName]} {
            # alertnote "entering subr: \/$subName\/"
            set fortTop $bol
            catch {unset fortDooz}
        }

        # Is the current line a comment line...
        #
        if {[regexp $comPat $thisLine allofit cc tag pre body]} {
            if {$FortmodeVars(indentComment) > 0} {
                set body [string trimright $body]
                # alertnote "comment line: \/$pre\/$body\/"
                set lwhite "$cc     "

                replaceText $bol $eol $lwhite$body
            }

        # ... or a line of code (possibly empty)?
        #
        } elseif {[regexp $lnumPat $thisLine allofit pre lnum post body]} {
            set body [string trimright $body]
            # alertnote "line: \/$pre\/$lnum\/$post\/$body\/"

            # is it a continuation line?
            #
            if {(![regexp {\t} $pre]) && ([string length $pre] == 5)} {
                set cont [string index $lnum$post$body 0]
                set body [string trimleft [string range $lnum$post$body 1 end]]
            } else {
                set cont {}
            }
            # alertnote "cont: \/$cont\/"

            # get whitespace for preceding line
            set enddo [getFortPrev $bol $lnum]
            set lwhite [getFortLwhite $bol]

            # if this line ends a block, decrease the whitespace
            if {[regexp $eobPat $body] || ($enddo && [regexp -nocase $enddoPat $body])} {
                set lwlen [expr [string length $lwhite] - 4]
                set lwhite [string range $lwhite 0 $lwlen]
            }

            if {[string length $lnum]} {
                if {[string index $lwhite 0] != $tab} {
                    set lwhite [string range $lwhite [expr [string length $lnum] +1] end]
                }
                set lnum " $lnum"
            }
            # alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
            # message "$msg : replacing text      "

            if {[string length $cont]} {
                replaceText $bol $eol "     $cont$lwhite$body"
            } else {
                replaceText $bol $eol $lnum$lwhite$body
                if {[string length $body] > 0} {
                    set fortPrevLine $lnum$lwhite$body
                }
            }
        } else {
            # message "$msg : Couldn't parse line         "
        }

        # message "$msg : Done                "
        incr from
    }
}

proc getFortLwhite {bol} {
    global fortDooz fortPrevLine fortTop msg
    # Define regexps
    set tab "    "
    set lnumPat {^([ \t]*)([0-9]*)([ \t]*)(.*)$}
    set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
    set bobPat {^(if[^\n\r]*then|else|do)}
    set enddoPat {^(end[ \t]*do|continue)}

    if {[regexp $lnumPat $fortPrevLine allofit pre0 lnum0 post0 body0]} {
        # alertnote "prevLine: \/$pre0\/$lnum0\/$post0\/$body0\/"

        if {[string length $lnum0]} {
            if {[string index $post0 0] == $tab} {
                set lwhite $post0
            } else {
                regsub -all {[0-9]} $pre0$lnum0$post0 { } lwhite
            }
        } else {
            set lwhite $pre0
        }
        # alertnote "lwhite: \/$lwhite\/ len: [string length $lwhite]"
        # message "$msg : got lwhite (initial)"

        # if there's a line number and it's not a CONTINUE or ENDDO,
        # then check for a matching DO statement and adjust
        # indentation if found
        #
        if {[string length $lnum0] && ![regexp -nocase $enddoPat $body0]} {
            if {[getFortPrev [lineStart [expr $bol - 1]] $lnum0]} {
                set lwlen [expr [string length $lwhite] - 4]
                set lwhite [string range $lwhite 0 $lwlen]

            }
        }

        # If the preceeding line begins a block (IF-THEN, DO, or ELSE),
        # then increase the whitespace
        #
        if {[regexp -nocase $bobPat $body0]} {
            set lwhite "$lwhite   "

            if {[regexp -nocase "$doPat\(\[0-9\]+\)" $body0 mtch donum]} {
                set eol [expr [nextLineStart $bol] - 1]
                set fortDooz($donum) [getText $bol $eol]
            }
        }
        # message "$msg : got lwhite (final)  "
    }
    return "$lwhite"
}

proc getFortPrev {bol lnum} {
    global fortDooz fortPrevLine fortTop msg
    # Define regexps
    set doPat {^[^cC*!\n\r][ \t]*do[ \t]+}
    set bolPat {^[^cC*!\n\r][ \t]*[^ \t\n\r][^\r\n]*$}
    set contPat {^     ([^ \t\n\r])[^\r\n]*$}

    # if there's a line number, check for a matching DO statement ...
    if {[string length $lnum]} {
        if {[lsearch [array names fortDooz] $lnum] >= 0} {
            set fortPrevLine $fortDooz($lnum)
            return 1
        } else {
            if {$fortTop < 0} {
                set fortTop [fortSubTop $bol]
            }
            if {![catch {search -s -f 0 -r 1 -i 1 -l $fortTop $doPat$lnum [expr $bol -1]} dolst]} {
                set fortPrevLine [eval getText $dolst]
                set fortDooz($lnum) $fortPrevLine
                # alertnote "doLine0: \/$fortPrevLine\/"
                return 1
            }
        }
    }

    # ... otherwise find the first preceding non-comment, non-continuation line
    if {[string length $fortPrevLine] == 0} {
        if {[catch {
            set lst [search -s -f 0 -r 1 -i 1 -s $bolPat [expr $bol-1]]
            set fortPrevLine [eval getText $lst]
            while {[regexp -nocase $contPat $fortPrevLine]} {
                set lst [search -s -f 0 -r 1 -i 1 $bolPat [expr [lindex $lst 0] - 1]]
                set fortPrevLine [eval getText $lst]
            }
        }]} {
            # if search fails, we're at the top of a file, so reset indentation
            set fortPrevLine "      continue"
        }
    }

    # alertnote "prevLine: \/$fortPrevLine\/"
    # message "$msg : got prevLine"
    return 0
}

# Find the beginning of the current subroutine
#
proc fortSubTop {{pos 0}} {
    if {$pos == 0} {
        set pos [lineStart [getPos]]
    }
    set subPat {^[^cC*!][ \ta-z*0-9]*(subroutine|.*function|entry|program)[ \t]+([a-z0-9_]+)}

    if {![catch {search -s -f 0 -r 1 -m 0 -i 1 $subPat $pos} sublst]} {
        # set subLine [eval getText $sublst]
        # alertnote "subLine: \/$subLine\/"
        return [lindex $sublst 0]
    } else {
        return 0
    }
}